(require scheme/base)

(define-struct finalist (number cumulative-marks cumulative-sums) #:inspector (make-inspector))
(define-struct (linked-finalist finalist) (places sum as-single-dance [r11 #:mutable]) #:inspector (make-inspector))

;; returns the cumulative marks at PLACE or above for FINALIST
(define (cumulative-marks finalist place)
  (list-ref (finalist-cumulative-marks finalist) (sub1 place)))

;; returns the sum of the cumulative marks at PLACE or above for FINALIST
(define (cumulative-sum finalist place)
  (list-ref (finalist-cumulative-sums finalist) (sub1 place)))

;; returns a list of two-element lists, each containing an element from LST
;; and the number of times it appears in LST.
;; ex. (count-occurrences '(a b a d b c b c)) => '((a 2) (b 3) (c 2) (d 1))
(define (count-occurrences lst)
  (hash-map
   (foldl (lambda (elt groups) (hash-set groups elt (add1 (hash-ref groups elt 0))))
          (make-immutable-hash empty)
          lst)
   list))

;; given a list of two-element lists, (competitor mark-count), and
;; a desired number of competitors to recall, returns either one or two
;; lists of (competitor mark-count) lists
(define (recalled mark-counts target)
  (let loop ([prev-set mark-counts] [cutoff 1] [set mark-counts])
    (let ([len (length set)])
      (cond
        [(= len target) (list set)]
        [(< len target) (list prev-set set)]
        [else ; (> len target)
         (let ([new-cutoff (add1 cutoff)])
           (loop set new-cutoff (filter (lambda (x) (>= (second x) new-cutoff)) set)))]))))

(define (build-list-from-marks op len marks)
  (build-list len (lambda (i) (op (filter (lambda (elt) (<= elt (add1 i))) marks)))))

;; judge-markings is of the form (number place place ...)
;; result is a list of finalist structures
(define (judge-markings->finalist judge-markings)
  (let ([num-judges (length judge-markings)]
        [marks (rest judge-markings)])
    (make-finalist (first judge-markings)
                   ;; counts of cumulative marks
                   (build-list-from-marks length num-judges marks)
                   ;; sums of cumulative marks
                   (build-list-from-marks (lambda (lst) (apply + lst)) num-judges marks))))

(define (rules5-8 finalists place-to-assign)
  (let ([majority (add1 (quotient (first (last-pair (finalist-cumulative-marks (first finalists)))) 2))]
        [max-place (length (finalist-cumulative-marks (first finalists)))])
    (let loop ([place 1] [contenders finalists])
      (let* ([contenders (sort (filter (lambda (f)
                                         (>= (cumulative-marks f place) majority))
                                       contenders)
                               > #:key (lambda (f) (cumulative-marks f place)))])
      (cond
        [(empty? contenders) (loop (add1 place) finalists)] ; rule 8
        [(empty? (rest contenders)) (list (cons place-to-assign contenders))] ; rule 5
        [else ; need to break ties
         ;; rule 6
         (let ([highest-marks (filter (lambda (c)
                                        (= (cumulative-marks c place) (cumulative-marks (first contenders) place)))
                                      contenders)])
           (if (empty? (rest highest-marks))
               (list (cons place-to-assign highest-marks)) ; unique highest majority
               ;; rule 7
               (let* ([sorted-by-sum (sort highest-marks < #:key (lambda (f) (cumulative-sum f place)))]
                      [lowest-sum (filter (lambda (f) (= (cumulative-sum f place) (cumulative-sum (first sorted-by-sum) place)))
                                           sorted-by-sum)])
                 (cond
                   [(empty? (rest lowest-sum)) (list (cons place-to-assign lowest-sum))] ; unique lowest sum
                   [(< place max-place)
                    (loop (add1 place) lowest-sum)] ; still tied: advance to next column
                   [else ; genuine tie
                    (let ([score (+ place-to-assign (/ (sub1 (length lowest-sum)) 2))])
                      (map (lambda (c) (list score c)) lowest-sum))]))))])))))

(define (compute-all-places finalists compute-next)
  (let loop ([placed empty] [unplaced finalists])
    (if (empty? unplaced)
        (reverse placed)
        (let ([newly-placed (compute-next unplaced (add1 (length placed)))])
          (loop (append newly-placed placed)
                (foldl (lambda (p u) (remove (second p) u)) unplaced newly-placed))))))

;; FINALISTS is a list of finalist structures
;; return value is a list of lists (place finalist), sorted by increasing place
(define (place-one-dance finalists)
  (compute-all-places finalists rules5-8))

(define (find number single-dance-result)
  (first (filter (lambda (place/finalist) (= number (finalist-number (second place/finalist))))
                 single-dance-result)))

(define (place-of number single-dance-result)
  (first (find number single-dance-result)))

;; SINGLE-DANCE-RESULTS is a list, each element of which is a return value from
;; PLACE-ONE-DANCE.
(define (single-dance-results->linked-finalists single-dance-results)
  (let ([num-finalists (length (first single-dance-results))])
    (map (lambda (f)
           (let* ([number (finalist-number f)]
                  [places (map (lambda (sdr) (place-of number sdr)) single-dance-results)])
             (make-linked-finalist number
                                   (build-list-from-marks length num-finalists places)
                                   (build-list-from-marks (lambda (lst) (apply + lst)) num-finalists places)
                                   places (apply + places)
                                   (let ([fs-single-dances (map (lambda (sdr)
                                                                  (second (find number sdr)))
                                                                single-dance-results)])
                                     (make-finalist number
                                                    (apply map + (map finalist-cumulative-marks fs-single-dances))
                                                    (apply map + (map finalist-cumulative-sums fs-single-dances))))
                                   #f)))
         (map second (first single-dance-results)))))

(define (rule9 linked-finalists place)
  (let* ([sorted (sort linked-finalists < #:key linked-finalist-sum)]
         [contenders (filter (lambda (lf) (= (linked-finalist-sum lf)
                                             (linked-finalist-sum (first sorted))))
                             sorted)])
    (if (empty? (rest contenders))
        (list (cons place contenders)) ; rule 9
        (rule10 contenders place))))

(define (rule10 contenders place)
  (let* ([by-count (sort contenders > #:key (lambda (lf) (cumulative-marks lf place)))]
         [highest-count (filter (lambda (lf) (= (cumulative-marks lf place)
                                                (cumulative-marks (first by-count) place)))
                                by-count)])
    (if (empty? (rest highest-count))
        (list (cons place highest-count)) ; rule 10, part 1
        (let* ([by-sum (sort highest-count < #:key (lambda (lf) (cumulative-sum lf place)))]
               [lowest-sum (filter (lambda (lf) (= (cumulative-sum lf place)
                                                   (cumulative-sum (first by-sum) place)))
                                   by-sum)])
          (if (empty? (rest lowest-sum))
              (list (cons place lowest-sum)) ; rule 10, part 2
              (rule11 lowest-sum place))))))

(define (rule11 lowest-sum place)
  (for-each (lambda (lf) (set-linked-finalist-r11! lf 'Rll)) lowest-sum)
  (let* ([results (rules5-8 (map linked-finalist-as-single-dance lowest-sum) place)]
         [placed (map (lambda (f)
                        (find (finalist-number f) (map (lambda (x) (list place x)) lowest-sum)))
                      (map second results))]
         [unplaced (foldl (lambda (p u) (remove (second p) u)) lowest-sum placed)])
    (if (empty? unplaced)
        placed
        (append (rule10 unplaced (+ place (length placed))) placed))))

(define (place-linked-dances linked-finalists)
  (compute-all-places linked-finalists rule9))

;;; For testing:

;; interesting cases: 1021971331 1025054504 625104625 123448584 122366323
(define cms (abs (current-milliseconds)))
(random-seed cms)

;; selects COUNT elements of SET at random
(define (select-at-random count set)
  (if (or (empty? set) (zero? count))
      empty
      (let ([elt (list-ref set (random (length set)))])
        (cons elt (select-at-random (sub1 count) (remove elt set))))))

;; generates COUNT unique random integers between MIN (inclusive) and MAX (exclusive)
(define (random-integers min max count)
  (select-at-random count (build-list (- max min) (lambda (i) (+ i min)))))

;; returns a list of JUDGE-COUNT-element lists, each containing a
;; MARK-COUNT-element subset of COMPETITOR-NUMS
(define (random-marks judge-count mark-count competitor-nums)
  (build-list judge-count (lambda (i) (select-at-random mark-count competitor-nums))))

;; returns the position of ELT in LST
(define (position elt lst)
  (cond
    [(empty? lst) (error "~a not found")]
    [(eq? elt (first lst)) 0]
    [else (add1 (position elt (rest lst)))]))

'random-quarterfinal:
(define competitors (sort (random-integers 101 400 24) <))
'competitors: competitors
(define marks (random-marks 5 12 competitors))
'sorted-marks-by-judge: (map (lambda (l) (sort l <)) marks)
(define mark-counts (sort (count-occurrences (apply append marks)) > #:key second))
'recall-possibilities:
(apply values (map (lambda (set) (map first (sort set < #:key first))) (recalled mark-counts 12)))

'random-final:
(define final-numbers (sort (select-at-random 6 competitors) <))
'competitors: final-numbers
(define inverse-judge-marks (build-list 5 (lambda (_) (select-at-random 6 final-numbers))))
'marks-by-judge:
(define judge-markings ;'((102 6 6 2 1 2) (129 1 2 6 2 4) (183 3 4 1 3 1) (190 5 1 5 5 6) (289 2 3 4 4 5) (369 4 5 3 6 3))
  (map (lambda (num)
         (cons num (build-list 5 (lambda (i) (add1 (position num (list-ref inverse-judge-marks i)))))))
       final-numbers))
judge-markings
(define finalists (map judge-markings->finalist judge-markings))
(define waltz (place-one-dance finalists))
'waltz:
waltz
'random-final:
(define inverse-judge-marks (build-list 5 (lambda (_) (select-at-random 6 final-numbers))))
'marks-by-judge:
(define judge-markings ;'((102 6 6 2 1 2) (129 1 2 6 2 4) (183 3 4 1 3 1) (190 5 1 5 5 6) (289 2 3 4 4 5) (369 4 5 3 6 3))
  (map (lambda (num)
         (cons num (build-list 5 (lambda (i) (add1 (position num (list-ref inverse-judge-marks i)))))))
       final-numbers))
judge-markings
(define finalists (map judge-markings->finalist judge-markings))
(define quickstep (place-one-dance finalists))
'quicktep:
quickstep
'random-final:
(define inverse-judge-marks (build-list 5 (lambda (_) (select-at-random 6 final-numbers))))
'marks-by-judge:
(define judge-markings ;'((102 6 6 2 1 2) (129 1 2 6 2 4) (183 3 4 1 3 1) (190 5 1 5 5 6) (289 2 3 4 4 5) (369 4 5 3 6 3))
  (map (lambda (num)
         (cons num (build-list 5 (lambda (i) (add1 (position num (list-ref inverse-judge-marks i)))))))
       final-numbers))
judge-markings
(define finalists (map judge-markings->finalist judge-markings))
(define tango (place-one-dance finalists))
'tango:
tango
(define linked-finalists (single-dance-results->linked-finalists (list waltz tango quickstep)))
linked-finalists
(place-linked-dances linked-finalists)
